home *** CD-ROM | disk | FTP | other *** search
/ Whiteline: Alpha / Whiteline Alpha.iso / progtool / pascal / o_gem / source / xaccspy.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1994-09-22  |  3.6 KB  |  147 lines
  1. {$IFDEF DEBUG}
  2.     {$B+,D+,G-,I-,L+,N-,P-,Q+,R+,S+,T-,V-,X+,Z+}
  3. {$ELSE}
  4.     {$B+,D-,G-,I-,L-,N-,P-,Q-,R-,S-,T-,V-,X+,Z+}
  5. {$ENDIF}
  6.  
  7. program XAccSpy;
  8.  
  9. uses
  10.  
  11.     Gem,OTypes,OProcs,OWindows;
  12.  
  13. type
  14.  
  15.     TXAccApplication = object(TApplication)
  16.         function GetIconTitle: string; virtual;
  17.         procedure InitMainWindow; virtual;
  18.         procedure IconPaint(Work: GRECT; var PaintInfo: TPaintStruct); virtual;
  19.         function XAccInsert(accID,mID: integer; Msg,Ver: byte; pName: PChar): boolean; virtual;
  20.         procedure XAccExit(OrgID: integer); virtual;
  21.     end;
  22.  
  23.     PXAccWindow = ^TXAccWindow;
  24.     TXAccWindow = object(TWindow)
  25.         function GetIconTitle: string; virtual;
  26.         procedure Paint(var PaintInfo: TPaintStruct); virtual;
  27.         procedure IconPaint(var PaintInfo: TPaintStruct); virtual;
  28.     end;
  29.  
  30. var
  31.  
  32.     XAccApplication: TXAccApplication;
  33.  
  34.  
  35. function TXAccApplication.GetIconTitle: string;
  36.  
  37.     begin
  38.         GetIconTitle:='XACC-SPY'
  39.     end;
  40.  
  41.  
  42. procedure TXAccApplication.InitMainWindow;
  43.  
  44.     begin
  45.         new(PXAccWindow,Init(nil,'ObjectGEM XAcc-Spy (04.02.94) von Thomas Much @ KA2'));
  46.         if (MainWindow=nil) or (ChkError<em_OK) then Status:=em_InvalidMainWindow
  47.     end;
  48.  
  49.  
  50. procedure TXAccApplication.IconPaint(Work: GRECT; var PaintInfo: TPaintStruct);
  51.     var dummy,cnt: integer;
  52.  
  53.     begin
  54.         if XAccList<>nil then cnt:=XAccList^.Count
  55.         else
  56.             cnt:=0;
  57.         vst_point(vdiHandle,8,dummy,dummy,dummy,dummy);
  58.         v_gtext(vdiHandle,Work.X,Work.Y+(Work.H shr 1),'  '+ltoa(cnt)+' APP.');
  59.         vst_height(vdiHandle,SysInfo.SFHeight,dummy,dummy,dummy,dummy)
  60.     end;
  61.  
  62.  
  63. function TXAccApplication.XAccInsert(accID,mID: integer; Msg,Ver: byte; pName: PChar): boolean;
  64.  
  65.     begin
  66.         XAccInsert:=inherited XAccInsert(accID,mID,Msg,Ver,pName);
  67.         MainWindow^.ForceRedraw
  68.     end;
  69.  
  70.  
  71. procedure TXAccApplication.XAccExit(OrgID: integer);
  72.  
  73.     begin
  74.         inherited XAccExit(OrgID);
  75.         MainWindow^.ForceRedraw
  76.     end;
  77.  
  78.  
  79. function TXAccWindow.GetIconTitle: string;
  80.  
  81.     begin
  82.         GetIconTitle:=Application^.GetIconTitle
  83.     end;
  84.  
  85.  
  86. procedure TXAccWindow.Paint(var PaintInfo: TPaintStruct);
  87.     var cnt,x,y,q,w,msk: integer;
  88.         txt,dummy      : string;
  89.  
  90.     begin
  91.         if Application^.XAccList<>nil then cnt:=Application^.XAccList^.Count
  92.         else
  93.             cnt:=0;
  94.         if cnt=0 then
  95.             begin
  96.                 SetSubTitle(' Keine XAcc-Applikation gefunden.');
  97.                 exit
  98.             end
  99.         else
  100.             SetSubTitle(' '+ltoa(cnt)+' XAcc-Applikation(en) gefunden.');
  101.         x:=Work.X+GP.charWidth;
  102.         y:=Work.Y+GP.boxHeight;
  103.         v_gtext(vdiHandle,x,y,'Name              apID  meID  Ver  Groups  apType + Features + genName');
  104.         inc(y,GP.boxHeight shl 1);
  105.         for q:=0 to pred(cnt) do
  106.             with PXAccAttr(Application^.XAccList^.At(q))^ do
  107.                 begin
  108.                     if Name<>nil then txt:=Name^ else txt:='';
  109.                     txt:=txt+StrPSpace(16-length(Name^))+'  ';
  110.                     dummy:=ltoa(apID);
  111.                     txt:=txt+StrPSpace(3-length(dummy))+dummy+'   ';
  112.                     dummy:=ltoa(menuID);
  113.                     txt:=txt+StrPSpace(3-length(dummy))+dummy+'   ';
  114.                     dummy:=ltoa(Version);
  115.                     txt:=txt+StrPSpace(3-length(dummy))+dummy+'  ';
  116.                     msk:=1;
  117.                     dummy:='';
  118.                     for w:=0 to 5 do
  119.                         begin
  120.                             if bTst(MsgGroups,msk) then dummy:=chr(w+49)+dummy
  121.                             else
  122.                                 dummy:='_'+dummy;
  123.                           msk:=msk shl 1
  124.                         end;
  125.                     txt:=txt+dummy+'  ';
  126.                     txt:=txt+AppTypeMR+' ';
  127.                     if AppTypeHR<>nil then txt:=txt+AppTypeHR^+'  ';
  128.                     if ExtFeatures<>nil then txt:=txt+ExtFeatures^+'  ';
  129.                     if GenericName<>nil then txt:=txt+GenericName^;
  130.                     v_gtext(vdiHandle,x,y,txt);
  131.                     inc(y,GP.boxHeight)
  132.                 end
  133.     end;
  134.  
  135.  
  136. procedure TXAccWindow.IconPaint(var PaintInfo: TPaintStruct);
  137.  
  138.     begin
  139.         Application^.IconPaint(Work,PaintInfo)
  140.     end;
  141.  
  142.  
  143. begin
  144.   XAccApplication.Init('XSPY','XAcc-Spy');
  145.   XAccApplication.Run;
  146.   XAccApplication.Done
  147. end.